home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Demos / browse.stk < prev    next >
Encoding:
Text File  |  1996-02-22  |  1.6 KB  |  53 lines
  1. #!/bin/sh
  2. :;exec /usr/local/bin/stk -f "$0" "$@"
  3. ;;;;
  4. ;;;; A simple STk browser 
  5. ;;;;
  6. ;;;; This script generates a directory browser, which lists the working
  7. ;;;; directory and allows you to open files or subdirectories by
  8. ;;;; double-clicking.
  9. ;;;; This is a new version of the demo which can be run before STk is installed
  10. ;;;;
  11. ;;;;
  12. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  13. ;;;;    Creation date:  3-Aug-1993 17:33
  14. ;;;; Last file update: 18-Sep-1995 14:25
  15.  
  16. (require "unix")
  17.  
  18. ;; Create a scrollbar on the right side of the main window and a listbox
  19. ;; on the left side.
  20. (frame '.f)
  21. (scrollbar '.f.scroll :command (lambda l (apply .f.list   'yview l)))
  22. (listbox   '.f.list   :yscroll (lambda l (apply .f.scroll 'set   l))
  23.                  :width 30 :height 20 :font "fixed")
  24.  
  25. (pack .f.scroll .f.list :side "right" :expand #t :fill "both")
  26. (pack .f :side "top" :fill "both" :expand #t)
  27.  
  28. (button '.quit :text "Quit" :command (lambda () (exit)))
  29. (pack .quit :fill "x" :side "bottom" :expand #t)
  30.  
  31. ;;;
  32. ;;; Callback
  33. ;;;
  34. (define (fill-listbox dir)
  35.   (chdir dir)
  36.   (.f.list 'delete 0 "end")
  37.   (apply .f.list 'insert 0 (sort (glob "*" ".*") string<?)))
  38.  
  39. (define (browse)
  40.   (catch 
  41.     (let ((file (string-append (getcwd) "/" (selection 'get))))
  42.       (cond
  43.         ((file-is-directory? file) (fill-listbox file))
  44.     ((file-is-readable? file)  (system (string-append "xedit " file "&")))
  45.     (else               (error "Bad directory or file ~S" file))))))
  46.  
  47.  
  48. ;; Fill the listbox with a list of all the files (in the given directory or ".")
  49. (fill-listbox (if (> *argc* 0) (car *argv*) (getcwd)))
  50.  
  51. ;; Set binding for "Double-click" on the listbox
  52. (bind .f.list "<Double-Button-1>" browse)
  53.